home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist01.zoo / lsp / gblocks.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-11-09  |  10.1 KB  |  374 lines
  1. ; Blocks World from Winston&Horn
  2.  
  3. (unless (fboundp 'defclass) (load 'classes))
  4.  
  5. ;
  6. ; Functions for graphic assistance
  7.  
  8. (setq *bx* 0)
  9. (setq *by* 22)
  10. (setq *gx* 50)
  11. (setq *gy* 100)
  12. (setq *ymax* 349)    ; height of display
  13. (setq *char-height* 14)    ; height of characters
  14. (setq *step-size* 10)    ; lcd of block widths 
  15.  
  16. ; Clear the screen
  17. (defun clear ()
  18.     (princ "\033[H\033[2J"))
  19.  
  20. ; Move the cursor
  21. (defun setpos (x y)
  22.     (princ "\033[") (princ y) (princ ";") (princ x) (princ "H") t)
  23.  
  24. ; Move the cursor to nearest position to graphic coordiates
  25. (defun setgpos (x y)
  26.      (setpos (/ (+ x *gx*) 8) (/ (+ (1- *char-height*) (- *ymax* y *gy*)) 
  27.                       *char-height*)))
  28.  
  29. ; Kill the remainder of the line
  30. (defun kill ()
  31.     (princ "\033[K") t)
  32.  
  33. ; Move the cursor to the currently set bottom position and clear the line
  34. ;  under it
  35. (defun bottom ()
  36.     (setpos *bx* (+ *by* 1))
  37.     (kill)
  38.     (setpos *bx* *by*)
  39.     (kill))
  40.  
  41. ; Clear the screen and go to the bottom
  42. (defun cb ()
  43.     (clear)
  44.     (bottom))
  45.  
  46.  
  47. ; Go to graphics mode
  48. (defun gmode () 
  49.        (mode 16)
  50.        (setq *by* 22)
  51.        (setq *ymax* 349) ; reset defaults
  52.        (setq *char-height* 14))
  53.  
  54. (defun gmode480 () ; this is for GENOA SuperEGA HiRes+
  55.        (mode 115 115 640 480)
  56.        (setq *ymax* 480)
  57.        (setq *by* 22)
  58.        (setq *char-height* 8))
  59.  
  60. (defun gmode600 () ; this is for GENOA SuperEGA HiRes+
  61.        (mode 121 121 800 600)
  62.        (setq *by* 22)
  63.        (setq *ymax* 600)
  64.        (setq *char-height* 8))
  65.  
  66. (defun gmodev () ; EVEREX 640x480 mode
  67.        (setq *by* 22)
  68.        (mode 112 0 640 480)
  69.        (setq *ymax* 480)
  70.        (setq *char-height* 14)
  71.        (display-blocks))
  72.  
  73. (defun gmodeVGA () ; standard 640x480 VGA
  74.        (mode 18 0 640 480)
  75.        (setq *ymax* 480)
  76.        (setq *by* 10)
  77.        (setq *char-height* 16)
  78.        (display-blocks))
  79.  
  80. (defun gmodeVGA800 () ; this is for Video 7 FastWrite/VRAM VGA
  81.        (mode 28421 98 800 600)
  82.        (setq *by* 22)
  83.        (setq *ymax* 600)
  84.        (setq *char-height* 8)
  85.        (display-blocks))
  86.  
  87. ; abstract classes for ball types
  88.  
  89. ; basic blocks support nothing
  90. (defclass basic-block (name color width height position supported-by))
  91.  
  92. (defmethod basic-block :support-for () nil)
  93.  
  94. (defmethod basic-block :top-location  () 
  95.     (list (+ (first position) (/ width 2))
  96.           (+ (second position) height)))
  97.  
  98. (defmethod basic-block :drawname ()
  99.     (setgpos (+ (first position) (/ width 2)) 
  100.              (+ (second position) (/ height 2)))
  101.     (princ name))
  102.  
  103. (defmethod basic-block :undrawname ()
  104.     (setgpos (+ (first position) (/ width 2)) 
  105.              (+ (second position) (/ height 2)))
  106.     (dotimes (i (flatc name)) (princ " ")))
  107.  
  108. (defmethod basic-block :draw ()
  109.     (color (+ color 128))
  110.     (move (+ *gx* (first position)) (+ *gy* (second position)))
  111.     (drawrel (1- width) 0 
  112.          0 (1- height)
  113.          (- 1 width) 0 
  114.          0 (- 1 height)))
  115.  
  116. ; movable-blocks can be moved
  117. (defclass movable-block () () basic-block)
  118.  
  119. (defmethod movable-block :new-position (newpos)
  120.     (send self :draw)
  121.     (send self :undrawname)
  122.     (setf position newpos)
  123.     (send self :drawname)
  124.     (send self :draw))
  125.  
  126. ; load-bearing blocks can support other blocks, and can be moved
  127. (defclass load-bearing-block (support-for) () movable-block)
  128.  
  129. ; we can't have multiple inheritance, so we need a separate class for table
  130. ; table blocks can support other blocks but cannot be moved.
  131.  
  132. (defclass table-block (support-for) () basic-block)
  133.  
  134. ; Specific classes for table brick wedge and ball
  135.  
  136. (defclass brick () () load-bearing-block)
  137.  
  138. (defclass wedge () () movable-block)
  139.  
  140. (defmethod wedge :draw ()
  141.     (color (+ color 128))
  142.     (move (+ *gx* (first position)) (+ *gy* (second position)))
  143.     (drawrel (1- width) 0 
  144.          (- 1 (/ width 2)) (1- height )
  145.          (- (/ width 2) width 1) (- 1 height)))
  146.  
  147. (defclass ball  () () movable-block)
  148.  
  149. (defmethod ball :draw ()
  150.     (color (+ color 128))
  151.     (let ((cx (+ (first position) (/ width 2) -1 *gx*))
  152.           (cy (+ (second position) (/ height 2) -1 *gy*))
  153.           (fstep (/ 3.14159 18))
  154.           (radius (1- (/ (min width height) 2))))
  155.          (move (+ cx radius) cy)
  156.          (dotimes (i 36)
  157.                   (draw (truncate (+ cx (* radius (cos (* (1+ i) fstep)))))
  158.                       (truncate (+ cy (* radius (sin (* (1+ i) fstep)))))))))
  159.  
  160. (defclass hand  (name position grasping))
  161.  
  162. (defmethod hand :top-location  () position)
  163.  
  164. (defmethod hand :draw ()
  165.     (color (if grasping 143 136))
  166.     (move (+ *gx* -7 (first position)) (+ *gy* (second position)))
  167.     (drawrel 5 0 0 10 5 0 0 -10 5 0 0 20 -15 0 0 -20))
  168.  
  169. (defmethod hand :new-position (newpos)
  170.     (send self :draw)
  171.     (setf position newpos)
  172.     (send self :draw))
  173.  
  174. ; define all the individual blocks
  175.  
  176. (setf *blocks*
  177.       (list
  178.         (send table-block :new :name 'table :width 430 :height 10 
  179.                    :position '(0 0) :color 7)
  180.     (send brick :new :name 'b1 :width 40 :height 40 
  181.                    :position '(0 10) :color 1)
  182.     (send brick :new :name 'b2 :width 40 :height 40 
  183.                    :position '(40 10) :color 2)
  184.     (send brick :new :name 'b3 :width 80 :height 80 
  185.                    :position '(80 10) :color 3)
  186.     (send brick :new :name 'b4 :width 40 :height 40 
  187.                    :position '(160 10) :color 4)
  188.     (send wedge :new :name 'w5 :width 40 :height 80 
  189.                    :position '(200 10) :color 5)
  190.     (send brick :new :name 'b6 :width 80 :height 40 
  191.                    :position '(240 10) :color 6)
  192.     (send wedge :new :name 'w7 :width 40 :height 40 
  193.                    :position '(320 10) :color 14)
  194.     (send ball  :new :name 'l8 :width 40 :height 40 
  195.                    :position '(360 10) :color 13)
  196.     (send brick :new :name 'b9 :width 30 :height 30 
  197.                    :position '(400 10) :color 12)
  198.        ))
  199.  
  200. (dolist (l *blocks*) (set (send l :name) l))
  201.  
  202. (dolist (l (rest *blocks*)) ; all blocks but the table
  203.     (setf (send table :support-for) 
  204.           (cons l (send table :support-for))
  205.           (send l :supported-by)
  206.           table))
  207.  
  208. (definst hand *hand* :name '*hand* :position '(0 120))
  209.  
  210. (defun display-blocks ()
  211.     (clear)
  212.     (dolist (l *blocks*) (send l :drawname)(send l :draw))
  213.     (send *hand* :draw)
  214.     (bottom)
  215.     t)
  216.  
  217. (defmethod basic-block :put-on (support) ; default case is bad
  218.     (format t
  219.         "Sorry, the ~a cannot be moved.~%"
  220.         name))
  221.  
  222. (defmethod movable-block :put-on (support)
  223.     (if (send self :get-space support)
  224.         (and (send *hand* :grasp self)
  225.              (send *hand* :move  self support)
  226.          (send *hand* :ungrasp self))
  227.         (format t
  228.                 "Sorry, there is no room for ~a on ~a.~%"
  229.             name
  230.             (send support :name))))
  231.  
  232. (defmethod movable-block :get-space (support)
  233.     (or (send self :find-space support)
  234.         (send self :make-space support)))
  235.  
  236. (defmethod hand :grasp (obj)
  237.     (unless (eq grasping obj)
  238.         (when (send obj :support-for)
  239.               (send obj :clear-top))
  240.         (when grasping
  241.               (send grasping :rid-of))
  242.         (let ((lift (max-height self obj)))
  243.              (send self :new-position lift)
  244.              (pause)
  245.              (send self :new-position 
  246.                  (list (first (send obj :top-location)) (second lift)))
  247.              (pause)
  248.              (send self :new-position (send obj :top-location))
  249.              (pause))
  250.         (send self :draw)
  251.         (setf grasping obj)
  252.         (send self :draw))
  253.     t)
  254.  
  255. (defmethod hand :ungrasp (obj)
  256.     (when (send obj :supported-by)
  257.           (send self :draw)
  258.           (setf grasping nil)
  259.           (send self :draw)
  260.           t))
  261.  
  262.  
  263. (defmethod movable-block :rid-of ()
  264.     (send self :put-on table))
  265.  
  266. (defmethod movable-block :make-space (support)
  267.     (dolist (obstruction (send support :support-for))
  268.         (send obstruction :rid-of)
  269.         (let ((space (send self :find-space support)))
  270.              (when space (return space)))))
  271.  
  272. (defmethod  load-bearing-block :clear-top ()
  273.     (dolist (obstacle support-for) (send obstacle :rid-of))
  274.     t)
  275.  
  276.  
  277. (defmethod hand :move (obj support)
  278.     (send obj :remove-support)
  279.     (let ((newplace (send obj :get-space support)))
  280.           (let ((lift (max-height obj support)))
  281.          (send obj :new-position lift)
  282.          (send self :new-position (send obj :top-location))
  283.          (pause)
  284.          (send obj :new-position (list (first newplace) (second lift)))
  285.               (send self :new-position (send obj :top-location))
  286.          (pause)
  287.          (send obj :new-position newplace)
  288.          (send self :new-position (send obj :top-location))
  289.          (pause)))
  290.     (send support :add-support obj)
  291.     t)
  292.  
  293.  
  294. ; helper function to find height necessary to move object
  295.  
  296. (defun max-height (obj1 obj2)
  297.     (let    ((source (first (send obj1 :top-location)))
  298.              (dest   (first (send obj2 :top-location))))
  299.     (let    ((roof 0) (min (min source dest)) (max (max source dest)) )
  300.         (dolist (obstacle *blocks*)
  301.             (let ((x (send obstacle :top-location)))
  302.                  (when (and (>= (first x) min)
  303.                          (<= (first x) max)
  304.                     (> (second x) roof))
  305.                    (setf roof (second x)))))
  306.         (list (first (send obj1 :position)) (+ 20 roof)))))
  307.                    
  308. (defun pause () (dotimes (x 5000)))
  309.  
  310.  
  311.  
  312. ; remove-support-for is defined twice, for each load bearing class
  313.  
  314. (defmethod load-bearing-block :remove-support-for (obj)
  315.     (setf support-for (remove obj support-for))
  316.     t)
  317.  
  318. (defmethod table-block :remove-support-for (obj)
  319.     (setf support-for (remove obj support-for))
  320.     t)
  321.  
  322. (defmethod movable-block :remove-support ()
  323.     (when supported-by
  324.           (send supported-by :remove-support-for self)
  325.           (setf supported-by nil))
  326.     t)
  327.  
  328.  
  329.  
  330. (defmethod load-bearing-block :add-support (obj)
  331.     (setf support-for 
  332.           (cons obj support-for)
  333.           (send obj :supported-by) 
  334.           self)
  335.     t)
  336.  
  337. (defmethod table-block :add-support (obj)
  338.     (setf support-for 
  339.           (cons obj support-for)
  340.           (send obj :supported-by) 
  341.           self)
  342.     t)
  343.  
  344. (defmethod basic-block :add-support (obj)
  345.     t)
  346.  
  347. (defmethod movable-block :find-space (support)
  348.     (do     ((offset (- (send support :width) width)
  349.                      (- offset *step-size*)))
  350.         ((< offset 0))
  351.          (unless (intersections-p self offset
  352.                        (first (send support :position))
  353.                       (send support :support-for))
  354.              (return (list (+ offset (first (send support 
  355.                                    :position)))
  356.                        (+ (second (send support :position))
  357.                           (send support :height)))))))
  358.  
  359. (defun intersections-p (obj offset base obstacles)
  360.     (dolist (obstacle obstacles)
  361.         (let* ((ls-proposed (+ offset base))
  362.             (rs-proposed (+ ls-proposed (send obj :width)))
  363.             (ls-obstacle (first (send obstacle :position)))
  364.             (rs-obstacle (+ ls-obstacle (send obstacle :width))))
  365.               (unless (or (>= ls-proposed rs-obstacle)
  366.                         (<= rs-proposed ls-obstacle))
  367.                   (return t)))))
  368.  
  369.  
  370. (gmode)
  371. (defun m (a b) (send a :put-on b) (bottom))
  372. (defun d () (display-blocks))
  373. (d)
  374.